home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 5
/
Apprentice-Release5.iso
/
Source Code
/
By the Book
/
Mac Pascal Primer, 4.0
/
Chap 7, Pager ƒ
/
Pager.p
next >
Wrap
Text File
|
1990-07-28
|
6KB
|
241 lines
program Pager;
const
BASE_RES_ID = 400;
SCROLL_BAR_PIXELS = 16;
MIN_SLEEP = 0;
NIL_REF_CON = 0;
WNE_TRAP_NUM = $60;
UNIMPL_TRAP_NUM = $9F;
ERROR_ALERT_ID = BASE_RES_ID + 1;
NO_WIND = BASE_RES_ID;
NO_PICTS = BASE_RES_ID + 1;
CANT_LOAD_PICT = BASE_RES_ID + 2;
NIL_STRING = '';
NIL_TITLE = NIL_STRING;
VISIBLE = TRUE;
START_VALUE = 1;
MIN_VALUE = 1;
HOPELESSLY_FATAL_ERROR = 'Game over, man!';
var
gPictWindow: WindowPtr;
gScrollBarHandle: ControlHandle;
gDone, gWNEImplemented: BOOLEAN;
gTheEvent: EventRecord;
{--------------------------------> ErrorHandler <---}
procedure ErrorHandler (stringNum: INTEGER);
var
errorStringH: StringHandle;
dummy: INTEGER;
begin
errorStringH := GetString(stringNum);
if errorStringH = nil then
ParamText(HOPELESSLY_FATAL_ERROR, NIL_STRING, NIL_STRING, NIL_STRING)
else
ParamText(errorStringH^^, NIL_STRING, NIL_STRING, NIL_STRING);
dummy := StopAlert(ERROR_ALERT_ID, nil);
ExitToShell;
end;
{--------------------------------> CenterPict <---}
procedure CenterPict (thePicture: PicHandle; var myRect: Rect);
var
windRect, pictureRect: Rect;
begin
windRect := myRect;
pictureRect := thePicture^^.picFrame;
myRect.top := (windRect.bottom - windRect.top - (pictureRect.bottom - pictureRect.top)) div 2 + windRect.top;
myRect.bottom := myRect.top + (pictureRect.bottom - pictureRect.top);
myRect.left := (windRect.right - windRect.left - (pictureRect.right - pictureRect.left)) div 2 + windRect.left;
myRect.right := myRect.left + (pictureRect.right - pictureRect.left);
end;
{--------------------------------> UpdateMyWindow <---}
procedure UpdateMyWindow (drawingWindow: WindowPtr);
var
currentPicture: PicHandle;
drawingClipRect, myRect: Rect;
tempRgn: RgnHandle;
begin
tempRgn := NewRgn;
GetClip(tempRgn);
myRect := drawingWindow^.portRect;
myRect.right := myRect.right - SCROLL_BAR_PIXELS;
EraseRect(myRect);
currentPicture := PicHandle(GetIndResource('PICT', GetCtlValue(gScrollBarHandle)));
if currentPicture = nil then
ErrorHandler(CANT_LOAD_PICT);
CenterPict(currentPicture, myRect);
drawingClipRect := drawingWindow^.portRect;
drawingClipRect.right := drawingClipRect.right - SCROLL_BAR_PIXELS;
ClipRect(drawingClipRect);
DrawPicture(currentPicture, myRect);
SetClip(tempRgn);
DisposeRgn(tempRgn);
end;
{--------------------------------> ScrollProc <---}
procedure ScrollProc (theControl: ControlHandle; theCode: INTEGER);
var
curControlValue, maxControlValue, minControlValue: INTEGER;
begin
maxControlValue := GetCtlMax(theControl);
curControlValue := GetCtlValue(theControl);
minControlValue := GetCtlMin(theControl);
case theCode of
inPageDown, inDownButton:
if curControlValue < maxControlValue then
curControlValue := curControlValue + 1;
inPageUp, inUpButton:
if curControlValue > minControlValue then
curControlValue := curControlValue - 1;
end;
SetCtlValue(theControl, curControlValue);
end;
{--------------------------------> SetUpScrollBar <---}
procedure SetUpScrollBar;
var
vScrollRect: Rect;
numPictures: INTEGER;
begin
numPictures := CountResources('PICT');
if numPictures <= 0 then
ErrorHandler(NO_PICTS);
vScrollRect := gPictWindow^.portRect;
vScrollRect.top := vScrollRect.top - 1;
vScrollRect.bottom := vScrollRect.bottom + 1;
vScrollRect.left := vScrollRect.right - SCROLL_BAR_PIXELS + 1;
vScrollRect.right := vScrollRect.right + 1;
gScrollBarHandle := NewControl(gPictWindow, vScrollRect, NIL_TITLE, VISIBLE, START_VALUE, MIN_VALUE, numPictures, scrollBarProc, NIL_REF_CON);
end;
{--------------------------------> HandleMouseDown <---}
procedure HandleMouseDown;
var
whichWindow: WindowPtr;
thePart: INTEGER;
thePoint: Point;
theControl: ControlHandle;
begin
thePart := FindWindow(gTheEvent.where, whichWindow);
case thePart of
inSysWindow:
SystemClick(gTheEvent, whichWindow);
inDrag:
DragWindow(whichWindow, gTheEvent.where, screenBits.bounds);
inContent:
begin
thePoint := gTheEvent.where;
GlobalToLocal(thePoint);
thePart := FindControl(thePoint, whichWindow, theControl);
if theControl = gScrollBarHandle then
begin
if thePart = inThumb then
begin
thePart := TrackControl(theControl, thePoint, nil);
UpdateMyWindow(whichWindow);
end
else
begin
thePart := TrackControl(theControl, thePoint, @ScrollProc);
UpdateMyWindow(whichWindow);
end;
end;
end;
inGoAway:
gDone := TRUE;
end;
end;
{--------------------------------> HandleEvent <---}
procedure HandleEvent;
var
dummy: BOOLEAN;
begin
if gWNEImplemented then
dummy := WaitNextEvent(everyEvent, gTheEvent, MIN_SLEEP, nil)
else
begin
SystemTask;
dummy := GetNextEvent(everyEvent, gTheEvent);
end;
case gTheEvent.what of
mouseDown:
HandleMouseDown;
updateEvt:
begin
BeginUpdate(WindowPtr(gTheEvent.message));
DrawControls(WindowPtr(gTheEvent.message));
UpdateMyWindow(WindowPtr(gTheEvent.message));
EndUpdate(WindowPtr(gTheEvent.message));
end;
end;
end;
{--------------------------------> MainLoop <---}
procedure MainLoop;
begin
gDone := FALSE;
gWNEImplemented := (NGetTrapAddress(WNE_TRAP_NUM, ToolTrap) <> NGetTrapAddress(UNIMPL_TRAP_NUM, ToolTrap));
while (gDone = FALSE) do
HandleEvent;
end;
{--------------------------------> WindowInit <---}
procedure WindowInit;
begin
gPictWindow := GetNewWindow(BASE_RES_ID, nil, WindowPtr(-1));
if gPictWindow = nil then
ErrorHandler(NO_WIND);
SelectWindow(gPictWindow);
ShowWindow(gPictWindow);
SetPort(gPictWindow);
end;
{--------------------------------> Pager <---}
begin
WindowInit;
SetUpScrollBar;
MainLoop;
end.